Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/demostuf/flame1.pas

Pascal/Delphi Source File | 1994-07-25 | 4.7 KB | 299 lines

program FLAMES;
{
  Flame #1
  - by Bjarke Viksφe
  may 1994

  THIS PROGRAM WAS CODED BY BJARKE VIKS0E.
  YOU ARE FREE TO DO WHATEVER YOU WANT WITH THIS PIECE OF CODE.
  E-MAIL ME AT: [e-mail] IN 1994 FOR CHAT AND CODE.

  Fairly simple to make. One bug remains.
  Got the idea from PCGPE 1.0. Read that for explanation.
}

{$A+,B-,G+,E+,I+,N-,X+}

uses
    DEMOINIT;

(*{$DEFINE DEBUG}*)

const
    MAXX = 160;
    MAXY = 70;

type
    pBigArray = ^BigArrayType;
    BigArrayType = array[0..MAXY-1, 0..MAXX-1] of byte;

var
    startpos : integer;
    startbuffer : pBigArray;

const
    display1 : word = $0000;
    display2 : word = $4000;
    display3 : word = $8000;

(*
{$DEFINE FLICKER}
const
    FLICKERCONST = 8;
*)

(*------------------------------------------------*)

procedure FaseColors(a,b, c1,c2,c3, d1,d2,d3 : integer);
var
    i : integer;
    r1,g1,b1 : longint;
    n,nadd : integer;
begin
    n:=1;
    nadd:=longdiv(256,b-a);
    for i:=a to b do begin
        r1:=(longdiv(longmul(d1-c1,n),256))+c1;
        g1:=(longdiv(longmul(d2-c2,n),256))+c2;
        b1:=(longdiv(longmul(d3-c3,n),256))+c3;
        SetRGB(i, r1,g1,b1);
        inc(n,nadd);
    end;
end;

procedure SetColors;
var
    i : integer;
begin
    FaseColors(0,4, 0,0,0, 0,0,0);
    FaseColors(5,9, 0,0,0, 0,0,6);
    FaseColors(10,45, 0,0,6, 43,0,0);
    FaseColors(46,75, 43,0,0, 63,30,10);
    FaseColors(76,85, 63,30,10, 63,60,10);
    FaseColors(86,149, 63,60,10, 63,63,63);
    FaseColors(150,255, 63,63,63, 63,43,0);
end;


procedure InitDemo;
var
    i : integer;
begin
    Randomize;
    ClearWholeScreen;
    SetColors;
    startpos:=0;
    New(startbuffer);
    FillChar(startbuffer^,sizeof(BigArrayType),0);
end;

procedure UninitDemo;
var
    i : integer;
begin
    Dispose(startbuffer);
end;


(*------------------------------------------------*)

procedure SwapDisplay;
var
    temp : word;
begin
    temp:=display3;
    display3:=display2;
    display2:=display1;
    display1:=temp;
    SetAddress(Ptr(SEGA000,display2));
end;


(*------------------------------------------------*)

procedure MakeRandomStuff;
var
    i : integer;
    thisy : word;
begin
    thisy:=startpos+(MAXY-3);
    if (thisy >= MAXY) then dec(thisy,MAXY);

    for i:=1 to MAXX-2 do
        if (random(2)=0) then startbuffer^[thisy,i]:=255
        else startbuffer^[thisy,i]:=20;
end;


procedure SmoothArray; assembler;
asm
    push    ds
    lds    di,startbuffer
    mov    ax,ds
    mov    es,ax
    xor    ax,ax
    xor    bx,bx
{$IFDEF FLICKER}
    mov    dl,FLICKERCONST
{$ENDIF}
    cld

    add    di,(MAXX)
    mov    dh,(MAXY-2)
@loop1:
    mov    cx,MAXX
@loop2:
    mov    al,[di]
    add    al,[di+1]
    adc    ah,bl
    add    al,[di-MAXX]
    adc    ah,bl
    add    al,[di+MAXX]
    adc    ah,bl
{$IFDEF FLICKER}
    xor    al,dl
{$ENDIF}
    shr    ax,2
    jz        @no1
    dec    al
@no1:
    stosb
    loop    @loop2
    dec    dh
    jnz    @loop1

    mov    ax,SEG @DATA
    mov    ds,ax
    lds    di,startbuffer
    xor    ax,ax
    mov    cx,MAXX
@loop_1line:
    mov    al,[di]
    add    al,[di+1]
    adc    ah,bl
    add    al,[di+(MAXX*(MAXY-1))]
    adc    ah,bl
    add    al,[di+MAXX]
    adc    ah,bl
{$IFDEF FLICKER}
    xor    al,dl
{$ENDIF}
    shr    ax,2
    jz        @no2
    dec    al
@no2:
    stosb
    loop    @loop_1line

    mov    ax,SEG @DATA
    mov    ds,ax
    lds    di,startbuffer
    add    di,(MAXX*(MAXY-1))
    xor    ax,ax
    mov    cx,MAXX-1
@loop_last_line:
    mov    al,[di]
    add    al,[di+1]
    adc    ah,bl
    add    al,[di-(MAXX*(MAXY-1))]
    adc    ah,bl
    add    al,[di-MAXX]
    adc    ah,bl
{$IFDEF FLICKER}
    xor    al,dl
{$ENDIF}
    shr    ax,2
    jz        @no3
    dec    al
@no3:
    stosb
    loop    @loop_last_line

    pop    ds
end;


(*------------------------------------------------*)

procedure CopyArray2Screen(arrayoffset : integer); assembler;
asm
    push    ds
    mov    es,SEGA000
    mov    di,display1
    add    di,WIDTH*35
    mov    dx,startpos
    lds    si,startbuffer
    add    si,arrayoffset
    mov    ax,MAXY-4
    cld
@copy1:
    mov    cx,(MAXX)/2
    push    ax
@copy2:
    movsb
    inc    si {only copy every 2nd pixel... other pixel is copied later!}
    loop    @copy2

    inc    dx
    cmp    dx,MAXY
    jb        @noswap
    xor    dx,dx
    sub    si,(MAXY*MAXX)
@noswap:
    pop    ax
    dec    ax
    jnz    @copy1
    pop    ds
end;

procedure CopyScreen;
var
    newoffset : integer;
begin
    newoffset:=longmul(startpos,MAXX);
    SetBitplanes(3);
    CopyArray2Screen(newoffset);
    SetBitplanes(12);
    CopyArray2Screen(newoffset+1);
end;


(*------------------------------------------------*)

procedure RunOnce;
var
    i : integer;
begin
    SwapDisplay;
    while retraces=0 do ;
    retraces:=0;
{$IFDEF DEBUG}
    i:=total_retraces;
    while i=total_retraces do ;
    SetRGB(0,30,0,0);
{$ENDIF}

    MakeRandomStuff;
    SmoothArray;
    CopyScreen;
    inc(startpos);    if (startpos = MAXY) then startpos:=0;

{$IFDEF DEBUG}
    SetRGB(0,0,0,0);
{$ENDIF}
end;


begin
    OpenScreen;
    Screen_Off;
    SetLinerepeat(3);
    InitDemo;
    SetAllInterrupts;
    Screen_On;
    repeat RunOnce until Key='e';
    RestoreAllInterrupts;
    UninitDemo;
    CloseScreen;
end.